home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d12
/
vol6n20.arc
/
PROFIL.ARC
/
CALCPRF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-10-31
|
13KB
|
439 lines
PROGRAM big_calculator;
(* ================================================================= *)
(* copyright 1985 by Neil J. Rubenking *)
(* This program does simple arithmetic on numbers of up to 254 digits*)
(* It was inspired by the BASIC program for the same purpose in the *)
(* March 1985 BYTE magazine. It could certainly be faster, but it *)
(* just as certainly WORKS. Compile to a .COM file and call from *)
(* the command line, e.g. *)
(* CALC 123456789 * 987654321 *)
(* CALC 19823746897698 / 872471234 *)
(* CALC 50 ! {this takes a while!} *)
(* ================================================================= *)
TYPE
numStr = STRING[255];
charset = SET OF Char;
VAR
op, opRand, result, rem : NumStr;
operation : Char;
FUNCTION RevString(A : numStr) : numStr;
VAR
N,L : Byte;
BEGIN
L := Length(A) + 1;
FOR N := 1 to (L DIV 2) DO
BEGIN
RevString[N] := A[L-N];
RevString[L-N] := A[N];
END;
RevString[0] := chr(L-1);
END;
PROCEDURE SwapStr(VAR A, B : numStr);
VAR
T : numStr;
BEGIN
T := A; A := B; B := T;
END;
PROCEDURE LCut(VAR S : numStr; Ch : Char);
{ PURPOSE : Remove all LEADING occurrences of character CH from word S}
VAR P : Byte;
BEGIN
P := 0;
WHILE S[P+1] = Ch DO P := P+1;
IF P > 0 THEN Delete(S, 1, P);
END;
PROCEDURE RPad(VAR S : numStr; Ch : Char);
{ PURPOSE : Pad word S out to its maximum length with character CH }
BEGIN
FillChar(S[Length(S)+1], 255-Length(S), Ch);
S[0] := Chr(255);
END;
FUNCTION SubChar(C1, C2 : Char; VAR borrow : Boolean) : Char;
{ PURPOSE : Subtract one numeric character from another, set "borrow" to
true if borrowing was necessary. }
VAR
temp : Integer;
BEGIN
temp := Ord(C1)-Ord(C2);
borrow := temp < 0;
temp := (temp+20) MOD 10;
SubChar := Chr(temp+48);
END;
FUNCTION AddChar(C1, C2 : Char; VAR carry : Boolean) : Char;
{ PURPOSE : Add one numeric character to another, set "carry" to true
as appropriate.}
VAR
temp : Byte;
BEGIN
temp := Ord(C1)+Ord(C2)-96;
carry := temp >= 10;
temp := temp MOD 10;
AddChar := Chr(temp+48);
END;
PROCEDURE RTrim(VAR S : numStr; CH : Char);
{ PURPOSE : Trim off all TRAILING occurrences of character CH from word S.}
VAR P : Byte;
BEGIN
P := Length(S);
WHILE S[P] = Ch DO P := P-1;
S[0] := Chr(P);
END;
PROCEDURE fWrite(VAR WW : numStr);
{ PURPOSE : Write formatted numeric string -- commas every three places. }
VAR
posn : Byte;
BEGIN
LCut(WW, '0');
IF Length(WW) > 3 THEN
BEGIN
posn := ((Length(WW)-1) MOD 3)+1;
Write(Copy(WW, 1, posn), ',');
posn := posn+1;
WHILE posn <= Length(WW) DO
BEGIN
Write(Copy(WW, posn, 3));
IF posn+3 < Length(WW) THEN Write(',');
posn := posn+3;
END;
END
ELSE
Write(WW);
END;
FUNCTION comp(VAR X, Y : numStr) : Char;
{ PURPOSE : Compare X and Y, return "<" if X is less, ">" if greater, or
"=" if they are equal. }
BEGIN
LCut(X, '0'); { cut off any leading zeroes }
LCut(Y, '0');
IF Length(X) = Length(Y) THEN
BEGIN
IF X = Y THEN
comp := '='
ELSE
IF X > Y THEN comp := '>'
ELSE comp := '<'
END
ELSE
BEGIN
IF Length(X) > Length(Y) THEN comp := '>'
ELSE comp := '<'
END;
END;
FUNCTION add(A, B : numStr) : numStr;
{ PURPOSE : Returns the sum of A and B. It reverses both strings and
adds the characters from start to finish, then reverses
the result.}
VAR
T : numStr;
posn : Byte;
carry : Boolean;
BEGIN
IF (Length(A) < 254) AND (Length(B) < 254) THEN
BEGIN
carry := False;
T := '';
RPad(T, ' ');
A := RevString(A);
B := RevString(B);
posn := 0;
WHILE (posn < Length(A)) AND (posn < Length(B)) DO
BEGIN
posn := posn+1;
IF carry THEN
T[posn] := AddChar(Succ(A[posn]), B[posn], carry)
ELSE T[posn] := AddChar(A[posn], B[posn], carry);
END;
IF posn < Length(A) THEN
WHILE posn < Length(A) DO
BEGIN
posn := posn+1;
IF carry THEN
T[posn] := AddChar(Succ(A[posn]), '0', carry)
ELSE T[posn] := AddChar(A[posn], '0', carry)
END;
IF posn < Length(B) THEN
WHILE posn < Length(B) DO
BEGIN
posn := posn+1;
IF carry THEN
T[posn] := AddChar(Succ(B[posn]), '0', carry)
ELSE T[posn] := AddChar(B[posn], '0', carry)
END;
IF carry THEN T[posn+1] := '1';
RTrim(T, ' ');
add := RevString(T);
END
ELSE
add := #7+'Operands must be 254 characters or less.';
END;
FUNCTION sub(A, B : numStr) : numStr;
{ PURPOSE : Subtract B from A. Similar in action to "add" above.}
VAR
T : numStr;
posn : Byte;
borrow, minus : Boolean;
BEGIN
IF (Length(A) < 254) AND (Length(B) < 254) THEN
BEGIN
borrow := False;
minus := False;
IF comp(A, B) = '<' THEN
BEGIN
minus := True;
SwapStr(A, B);
END;
A := RevString(A);
B := RevString(B);
T := '';
RPad(T, ' ');
posn := 0;
WHILE (posn < Length(A)) AND (posn < Length(B)) DO
BEGIN
posn := posn+1;
IF borrow THEN
T[posn] := subChar(Pred(A[posn]), B[posn], borrow)
ELSE T[posn] := subChar(A[posn], B[posn], borrow);
END;
IF posn < Length(A) THEN
WHILE posn < Length(A) DO
BEGIN
posn := posn+1;
IF borrow THEN
T[posn] := subChar(Pred(A[posn]), '0', borrow)
ELSE T[posn] := subChar(A[posn], '0', borrow);
END;
RTrim(T, ' ');
IF minus THEN T := T+'-';
sub := RevString(T);
END
ELSE
sub := #7+'Operands must be 254 characters or less.';
END;
FUNCTION prod(A, B : numStr) : NumStr;
{ PURPOSE : Returns the product of A and B. It first selects the smaller of
the two as a multiplier and then finds the product by repeated
addition. No, it doesn't repeat 12,345 times to multiply by
12,345 -- it does each digit and tacks on zeroes as needed.}
VAR
T1, T2 : numStr;
posn, times, N : Byte;
BEGIN
IF (Length(A)+Length(B)) < 254 THEN
BEGIN
IF comp(A, B) = '<' THEN
SwapStr(A, B);
B := RevString(B);
T2 := '0';
FOR posn := 1 TO Length(B) DO
BEGIN
times := Ord(B[posn])-48;
CASE times OF
0 : T1 := '0';
1 : T1 := A;
ELSE
T1 := A;
FOR N := 2 TO times DO
T1 := add(T1, A);
END;
IF posn > 1 THEN
FOR N := 2 TO posn DO
T1 := T1+'0';
T2 := add(T2, T1);
END;
prod := T2;
END
ELSE
prod := #7+'Overflow -- operand lengths must total 254 or less.';
END;
FUNCTION fact(VAR A : numStr) : numStr;
{ PURPOSE : Returns A factorial. Note that this is NOT a lovely recursive
function -- you can fill the entire stack space of the computer
with copies of a recursive function when the numbers get big.}
VAR
T1, T2 : numStr;
BEGIN
T1 := '1';
T2 := '1';
IF (A <> '1') AND (A <> '0') THEN
WHILE T2 <> A DO
BEGIN
T2 := add(T2, '1');
T1 := prod(T1, T2);
END;
fact := T1;
END;
FUNCTION divide(A, B : numStr; VAR remainder : numStr) : numStr;
{ PURPOSE : Returns the quotient of A / B -- also the remainder.
Uses repeated subtraction}
VAR
T1, T2, T3 : numStr;
BEGIN
IF comp(A, B) = '=' THEN
BEGIN
divide := '1';
remainder := '0';
END
ELSE
BEGIN
T1 := B; T2 := '1'; T3 := '0';
WHILE comp(A, T1) = '>' DO
BEGIN
T1 := T1+'0';
T2 := T2+'0';
END;
WHILE NOT(comp(T1, B) = '=') DO
BEGIN
T1[0] := Pred(T1[0]);
T2[0] := Pred(T2[0]);
WHILE NOT(comp(A, T1) = '<') DO
BEGIN
A := sub(A, T1);
T3 := add(T3, T2);
END;
END;
divide := T3;
remainder := A;
END;
END;
FUNCTION AllNums(VAR A : numStr) : Boolean;
{ PURPOSE : Returns true IFF a string is all numbers }
VAR
N : Byte;
temp : Boolean;
BEGIN
temp := True;
N := 1;
WHILE (N <= Length(A)) AND Temp DO
BEGIN
IF NOT(A[N] IN ['0'..'9']) THEN temp := False;
N := N+1;
END;
AllNums := temp;
END;
FUNCTION GotParams : Boolean;
{ PURPOSE : Returns true if parameters are correctly passed on the command
line -- and assigns them to the correct variables if so.}
VAR
temp : Boolean;
BEGIN
IF ParamCount > 1 THEN
BEGIN
op := ParamStr(1);
IF AllNums(op) THEN
BEGIN
operation := ParamStr(2);
operation := UpCase(operation);
IF operation IN ['+', '-', '*', '/', '!'] THEN
BEGIN
IF operation <> '!' THEN
BEGIN
IF ParamCount > 2 THEN
BEGIN
opRand := ParamStr(3);
IF AllNums(opRand) THEN temp := True
ELSE
BEGIN
temp := False;
WriteLn(opRand, ' is not all numeric.');
END;
END
ELSE
BEGIN
temp := False;
WriteLn(op, ' ', operation, ' what?');
END;
END
ELSE
temp := True;
END
ELSE
BEGIN
temp := False;
Write('Operations are +, -, *, / and !');
END;
END
ELSE
BEGIN
temp := False;
WriteLn(op, ' is not all numeric.');
END;
END
ELSE
BEGIN
temp := False;
WriteLn('Enter "CALC ## op ##", where op is +,-,*,/ or !')
END;
GotParams := temp;
END;
procedure Calculate ; { This line added for use with profiler }
BEGIN
IF GotParams THEN
BEGIN
CASE operation OF
'+' : BEGIN
Write(' SUM: '); Flush(output);
result := add(op, opRand);
FWrite(result);
END;
'-' : BEGIN
Write('DIFFERENCE: '); Flush(output);
result := sub(op, opRand);
FWrite(result);
END;
'*' : BEGIN
Write(' PRODUCT: '); Flush(output);
result := prod(op, opRand);
FWrite(result);
END;
'/' : BEGIN
Write(' QUOTIENT: '); Flush(output);
result := divide(op, opRand, rem);
FWrite(result);
WriteLn;
Write('REMAINDER: ');
FWrite(rem);
END;
'!' : BEGIN
Write(' FACTORIAL: '); Flush(output);
result := fact(op);
FWrite(result);
END;
END;
END;
END;
{ Everything from here to end added for use by profiler }
procedure dummy ;
begin
end;
{$I profile.inc}
begin
PRF_Init( CSeg, Ofs(RevString), Ofs(dummy) ) ;
PRF_Start ;
Calculate ;
PRF_Stop ;
end.